home *** CD-ROM | disk | FTP | other *** search
/ PCGUIA 127 / PC Guia 127.iso / Software / Produtividade / OpenOffice.org 2.0.1 / openofficeorg1.cab / API.xba < prev    next >
Extensible Markup Language  |  2004-04-02  |  7KB  |  208 lines
  1. <?xml version="1.0" encoding="UTF-8"?>
  2. <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
  3. <script:module xmlns:script="http://openoffice.org/2000/script" script:name="API" script:language="StarBasic">Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
  4.  (ByVal hKey As Long, _
  5.   ByVal lpSubKey As String, _
  6.   ByVal ulOptions As Long, _
  7.   ByVal samDesired As Long, _
  8.   phkResult As Long) As Long
  9.  
  10. Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _
  11.  (ByVal hKey As Long, _
  12.   ByVal lpValueName As String, _
  13.   ByVal lpReserved As Long, _
  14.   lpType As Long, _
  15.   lpData As String, _
  16.   lpcbData As Long) As Long
  17.  
  18. Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" _
  19.  (ByVal hKey As Long, _
  20.   ByVal lpValueName As String, _
  21.   ByVal lpReserved As Long, _
  22.   lpType As Long, _
  23.   lpData As Long, _
  24.   lpcbData As Long) As Long
  25.  
  26. Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" _
  27.  (ByVal hKey As Long, _
  28.   ByVal lpValueName As String, _
  29.   ByVal lpReserved As Long, _
  30.   lpType As Long, _
  31.   ByVal lpData As Long, _
  32.   lpcbData As Long) As Long
  33.  
  34. Declare Function RegCloseKeyA Lib "advapi32.dll" Alias "RegCloseKey" _
  35.  (ByVal hKey As Long) As Long
  36.  
  37.  
  38. Public Const HKEY_CLASSES_ROOT = &H80000000
  39. Public Const HKEY_CURRENT_USER = &H80000001
  40. Public Const HKEY_LOCAL_MACHINE = &H80000002
  41. Public Const HKEY_USERS = &H80000003
  42. Public Const KEY_ALL_ACCESS = &H3F
  43. Public Const REG_OPTION_NON_VOLATILE = 0
  44. Public Const REG_SZ As Long = 1
  45. Public Const REG_DWORD As Long = 4
  46. Public Const ERROR_NONE = 0
  47. Public Const ERROR_BADDB = 1
  48. Public Const ERROR_BADKEY = 2
  49. Public Const ERROR_CANTOPEN = 3
  50. Public Const ERROR_CANTREAD = 4
  51. Public Const ERROR_CANTWRITE = 5
  52. Public Const ERROR_OUTOFMEMORY = 6
  53. Public Const ERROR_INVALID_PARAMETER = 7
  54. Public Const ERROR_ACCESS_DENIED = 8
  55. Public Const ERROR_INVALID_PARAMETERS = 87
  56. Public Const ERROR_NO_MORE_ITEMS = 259
  57. 'Public Const KEY_READ = &H20019
  58.  
  59.  
  60. Function OpenRegKey(lBaseKey As Long, sKeyName As String) As Variant
  61. Dim LocKeyValue
  62. Dim hKey as Long
  63. Dim lRetValue as Long
  64.     lRetValue = RegOpenKeyEx(lBaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
  65. '    lRetValue = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Outlook Express\5.0\Default Settings", "Revocation Checking")
  66.     If hKey <> 0 Then
  67.         RegCloseKeyA (hKey)
  68.     End If
  69.     OpenRegKey() = lRetValue
  70. End Function
  71.  
  72.  
  73. Function GetDefaultPath(CurOffice as Integer) As String
  74. Dim sPath as String
  75. Dim Index as Integer
  76.     Select Case Wizardmode
  77.         Case SBMICROSOFTMODE
  78.             Index = Applications(CurOffice,SBAPPLKEY)
  79.             If GetGUIType = 1 Then ' Windows
  80.                 sPath = QueryValue(HKEY_LOCAL_MACHINE, sKeyName(Index), sValueName(Index))
  81.             Else
  82.                 sPath = ""
  83.             End If
  84.             If sPath = "" Then
  85.                 sPath = SOWorkPath
  86.             End If
  87.             GetDefaultPath = sPath
  88.         Case SBXMLMODE
  89.             GetDefaultPath = SOWorkPath
  90.     End Select
  91. End Function
  92.  
  93.  
  94. Function GetTemplateDefaultPath(Index as Integer) As String
  95. Dim sLocTemplatePath as String
  96. Dim sLocProgrampath as String
  97. Dim Progstring as String
  98. Dim PathList()as String
  99. Dim Maxindex as Integer
  100. Dim OldsLocTemplatePath
  101. Dim sTemplateKeyName as String
  102. Dim sTemplateValueName as String
  103.     On Local Error Goto NOVAlIDSYSTEMPATH
  104.     Select Case WizardMode
  105.         Case SBMICROSOFTMODE
  106.             If GetGUIType = 1 Then ' Windows
  107.                 ' Template directory of Office 97
  108.                 sTemplateKeyName = "Software\Microsoft\Office\8.0\Common\FileNew\LocalTemplates"
  109.                 sTemplateValueName = ""
  110.                 sLocTemplatePath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName)
  111.  
  112.                 If sLocTemplatePath = "" Then
  113.                     ' Retrieve the template directory of Office 2000
  114.                     ' Unfortunately there is no existing note about the template directory in
  115.                     ' the whole registry.
  116.  
  117.                     ' Programdirectory of Office 2000
  118.                     sTemplateKeyName = "Software\Microsoft\Office\9.0\Common\InstallRoot"
  119.                     sTemplateValueName = "Path"
  120.                     sLocProgrampath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName)
  121.                     If sLocProgrampath <> "" Then
  122.                         If Right(sLocProgrampath, 1) <> "\" Then
  123.                             sLocProgrampath = sLocProgrampath & "\"
  124.                            End If
  125.                         PathList() = ArrayoutofString(sLocProgrampath,"\",Maxindex)
  126.                         Progstring = "\" & PathList(Maxindex-1) & "\"
  127.                         OldsLocTemplatePath = DeleteStr(sLocProgramPath,Progstring)
  128.  
  129.                         sLocTemplatePath = OldsLocTemplatePath & "\" & "Templates"
  130.  
  131.                         ' Does this subdirectory "templates" exist at all
  132.                         If oUcb.Exists(sLocTemplatePath) Then
  133.                             ' If Not the main directory of the office is the base
  134.                             sLocTemplatePath = OldsLocTemplatePath
  135.                         End If
  136.                     Else
  137.                         sLocTemplatePath = SOWorkPath
  138.                     End If
  139.                 End If
  140.                 GetTemplateDefaultPath = ConvertToUrl(sLocTemplatePath)
  141.             Else
  142.                 GetTemplateDefaultPath = SOWorkPath
  143.             End If
  144.         Case SBXMLMODE
  145.             If Index = 3 Then
  146.                 ' Helper Application with no templates
  147.                 GetTemplateDefaultPath = SOWorkPath
  148.             Else
  149.                 GetTemplateDefaultPath = SOTemplatePath
  150.             End If
  151.     End Select
  152. NOVALIDSYSTEMPATH:
  153.     If Err <> 0 Then
  154.         GetTemplateDefaultPath() = SOWorkPath
  155.         Resume ONITGOES
  156.         ONITGOES:
  157.     End If    
  158. End Function
  159.  
  160.  
  161. Function QueryValueEx(ByVal lhKey, ByVal szValueName As String, vValue As String) As Long
  162. Dim cch As Long
  163. Dim lrc As Long
  164. Dim lType As Long
  165. Dim lValue As Long
  166. Dim sValue As String
  167. Dim Empty
  168.  
  169.     On Error GoTo QueryValueExError
  170.  
  171.     lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
  172.     If lrc <> ERROR_NONE Then Error 5
  173.     Select Case lType
  174.         Case REG_SZ:
  175.             sValue = String(cch, 0)
  176.             lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
  177.             If lrc = ERROR_NONE Then
  178.                 vValue = Left$(sValue, cch)
  179.             Else
  180.                 vValue = Empty
  181.             End If
  182.         Case REG_DWORD:
  183.             lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
  184.             If lrc = ERROR_NONE Then
  185.                 vValue = lValue
  186.             End If
  187.         Case Else
  188.             lrc = -1
  189.     End Select
  190. QueryValueExExit:
  191.     QueryValueEx = lrc
  192.     Exit Function
  193. QueryValueExError:
  194.     Resume QueryValueExExit
  195. End Function
  196.  
  197.  
  198. Function QueryValue(BaseKey As Long, sKeyName As String, sValueName As String) As Variant
  199. Dim lRetVal As Long         ' Returnvalue API-Call
  200. Dim hKey As Long            ' Onen key handle
  201. Dim vValue As String        ' Key value
  202.  
  203.     lRetVal = RegOpenKeyEx(BaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
  204.     lRetVal = QueryValueEx(hKey, sValueName, vValue)
  205.     RegCloseKeyA (hKey)
  206.     QueryValue = vValue
  207. End Function
  208. </script:module>